perm filename EVAL2.LSP[W78,JMC] blob sn#339346 filedate 1978-03-09 generic text, type T, neo UTF8

(DEFUN FFEVAL (E A) 
       (COND ((ATOM E)
	      (COND ((OR (EQ E NIL) (EQ E T)) E)
		    (T (CDR (FFASSOC E A)))))
	     ((ATOM (CAR E))
	      (COND ((EQ (CAR E) 'QUOTE) (CADR E))
		    ((EQ (CAR E) 'CAR)
		     (CAR (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'CDR)
		     (CDR (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'CADR)
		     (CADR (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'CADDR)
		     (CADDR (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'CAAR)
		     (CAAR (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'CADAR)
		     (CADAR (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'CADDAR)
		     (CADDAR (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'ATOM)
		     (ATOM (FFEVAL (CADR E) A)))
		    ((EQ (CAR E) 'CONS)
		     (CONS (FFEVAL (CADR E) A) (FFEVAL (CADDR E) A)))
		    ((EQ (CAR E) 'EQ)
		     (EQ (FFEVAL (CADR E) A) (FFEVAL (CADDR E) A)))
		    ((EQ (CAR E) 'COND) (FFEVCOND (CDR E) A))
		    (T (FFEVAL (CONS (CDR (FFASSOC (CAR E) A))
				     (CDR E))
			       A))))
	     ((EQ (CAAR E) 'LAMBDA)
	      (FFEVAL (CADDAR E)
		      (APPEND (PAIRUP (CADAR E) (FFEVLIS (CDR E) A))
			      A)))
	     ((EQ (CAAR E) 'LABEL)
	      (FFEVAL (CONS (CADDAR E) (CDR E))
		      (CONS (CONS (CADAR E) (CAR E)) A))))) 

(DEFUN FFEVLIS (U A) 
       (COND ((NULL U) NIL)
	     (T (CONS (FFEVAL (CAR U) A) (FFEVLIS (CDR U) A))))) 

(DEFUN FFEVCOND (U A) 
       (COND ((FFEVAL (CAAR U) A) (FFEVAL (CADAR U) A))
	     (T (FFEVCOND (CDR U) A)))) 

(DEFUN FFASSOC (E A) 
       (COND ((NULL A) NIL)
	     ((EQ E (CAAR A)) (CAR A))
	     (T (FFASSOC E (CDR A))))) 

(DEFUN PAIRUP (U V) 
       (COND ((NULL U) NIL)
	     (T (CONS (CONS (CAR U) (CAR V))
		      (PAIRUP (CDR U) (CDR V))))))